'AutoCAD ǰļע·
'2000İ       HKEY_LOCAL_MACHINE\SOFTWARE\Autodesk\AutoCAD\R14.0\ACAD-1:804
'2002İ       HKEY_LOCAL_MACHINE\SOFTWARE\Autodesk\AutoCAD\R15.0\ACAD-1:804
'2004İ       HKEY_LOCAL_MACHINE\SOFTWARE\Autodesk\AutoCAD\R16.0\ACAD-201:804
'2005İ       HKEY_LOCAL_MACHINE\SOFTWARE\Autodesk\AutoCAD\R16.1\ACAD-301:804
'2006İ   --- HKEY_LOCAL_MACHINE\SOFTWARE\\Autodesk\AutoCAD\R16.2\ACAD-4001:804
'2007İ   --- HKEY_LOCAL_MACHINE\SOFTWARE\\Autodesk\AutoCAD\R17.0\ACAD-5001:804
'2008İ   --- HKEY_LOCAL_MACHINE\SOFTWARE\\Autodesk\AutoCAD\R17.1\ACAD-6001:804
'2009İ   --- HKEY_LOCAL_MACHINE\SOFTWARE\\Autodesk\AutoCAD\R17.2\ACAD-7001:804
Function GetActiveProfileRegPath() As String
    Dim Version As String
    Dim ActiveProfile As String
    Dim Language As String
    Version = Left(AcadApplication.Version, 4)
    ActiveProfile = AcadApplication.Preferences.Profiles.ActiveProfile
    Select Case Version
        Case "14.0"
            Language = "ACAD-1:804"
        Case "15.0"
            Language = "ACAD-1:804"
        Case "16.0"
            Language = "ACAD-201:804"
        Case "16.1"
            Language = "ACAD-301:804"
        Case "16.2"
            Language = "ACAD-4001:804"
        Case "17.0"
            Language = "ACAD-5001:804"
        Case "17.1"
            Language = "ACAD-6001:804"
        Case "17.2"
            Language = "ACAD-7001:804"
    End Select
    GetActiveProfileRegPath = "SOFTWARE\Autodesk\AutoCAD\R" & Version & "\" & Language & "\Profiles\" & ActiveProfile
End Function


ӭתأת[ݲwww.tiancao.net] ԭӣhttp://www.tiancao.net/blogview.asp?logID=678&cateID=3




Private Sub UserForm_Initialize()
    'AutoCADİ汾ȷʹObjectDBXİ汾
    If Left(Version, 2) = "15" Then
        Set objDbx = CreateObject("ObjectDBX.AxDbDocument.1")
    ElseIf Left(Version, 2) = "16" Then
        Set objDbx = CreateObject("ObjectDBX.AxDbDocument.16")
    End If
End Sub

ӭתأת[ݲwww.tiancao.net] ԭӣhttp://www.tiancao.net/blogview.asp?logID=676&cateID=3

'ȡûѾװCAD汾
Sub GetAllCADVersion()
    Dim hKey As Long
    Dim i
    Dim Temp As String * 256
        Temp = Space(256)
        If RegOpenKey(HKEY_LOCAL_MACHINE, "SOFTWARE\\Autodesk\AutoCAD", hKey) = ERROR_SUCCESS Then
        While RegEnumKey(hKey, i, Temp, 256) = ERROR_SUCCESS
            Select Case Left(Trim(Temp), Len(Trim(Temp)) - 1)
                Case "R14.0"
                Me.Check1.Value = 1: Me.Check1.Enabled = True
                Case "R15.0"
                Me.Check2.Value = 1: Me.Check2.Enabled = True
                Case "R16.0"
                Me.Check3.Value = 1: Me.Check3.Enabled = True
                Case "R16.1"
                Me.Check4.Value = 1: Me.Check4.Enabled = True
                Case "R16.2"
                Me.Check5.Value = 1: Me.Check5.Enabled = True
                Case "R17.0"
                Me.Check6.Value = 1: Me.Check6.Enabled = True
                Case "R17.1"
                Me.Check7.Value = 1: Me.Check7.Enabled = True
            End Select
            
            i = i + 1
        Wend
        RegCloseKey hKey
    End If
End Sub


ӭתأת[ݲwww.tiancao.net] ԭӣhttp://www.tiancao.net/blogview.asp?logID=336&cateID=3

'ֱתΪ
Sub LineToSPline()
    Dim E  As AcadEntity
    Dim L  As AcadLine
    Dim StartTan(0 To 2) As Double 'ָߵ
    Dim FitPoints(0 To 8) As Double 'ָߵϵ?
    Dim CenterP As Variant 'ֱе
    Dim a(0 To 2) As Double 'ߵĶ˵յķ
    Dim n As Long
    Dim i As Long
    Dim Sp As AcadSpline
    n = ThisDrawing.ModelSpace.Count
    For Each E In ThisDrawing.ModelSpace
        i = i + 1
        ThisDrawing.Utility.Prompt Int(i / n * 100) & "%" & vbCrLf
        DoEvents
        'ThisDrawing.Utility.Prompt L.ObjectName
        'If e.ObjectName = "AcDbLine" Then
        If TypeOf E Is AcadLine Then
            Set L = E
            
            CenterP = centerPoint(L.StartPoint, L.EndPoint)
            
            a(0) = L.StartPoint(0) - L.EndPoint(0)
            a(1) = L.StartPoint(1) - L.EndPoint(1)
            a(2) = L.StartPoint(1) - L.EndPoint(1)
            
            FitPoints(0) = L.StartPoint(0):     FitPoints(1) = L.StartPoint(1):     FitPoints(2) = L.StartPoint(2)
            FitPoints(3) = CenterP(0):          FitPoints(4) = CenterP(1):          FitPoints(5) = CenterP(2)
            FitPoints(6) = L.EndPoint(0) + 0.001:   FitPoints(7) = L.EndPoint(1) + 0.001:   FitPoints(8) = L.EndPoint(2)
            
            StartTan(0) = -a(0):      StartTan(1) = -a(1):      StartTan(2) = -a(2)
            
            Set Sp = ThisDrawing.ModelSpace.AddSpline(FitPoints, StartTan, StartTan)
            Sp.Layer = L.Layer
            Sp.color = L.color
            L.Delete
        End If
    Next E
End Sub

ӭתأת[ݲwww.tiancao.net] ԭӣhttp://www.tiancao.net/blogview.asp?logID=235&cateID=3

תΪֱ(溯ת)
Sub SPlineToLine()
    Dim E  As AcadEntity
    Dim L  As AcadLine
    Dim SP As AcadSpline
    Dim StartP As Variant
    Dim EndP As Variant
    
    For Each E In ThisDrawing.ModelSpace
        'DoEvents
        'ThisDrawing.Utility.Prompt E.ObjectName
        If E.ObjectName = "AcDbSpline" Then
            Set SP = E
            
            StartP = SP.GetFitPoint(0)
            EndP = SP.GetFitPoint(2)
            
            Set L = ThisDrawing.ModelSpace.AddLine(StartP, EndP)
            L.Layer = SP.Layer
            L.color = SP.color
            SP.Delete
        End If
    Next E
End Sub

ӭתأת[ݲwww.tiancao.net] ԭӣhttp://www.tiancao.net/blogview.asp?logID=235&cateID=3

CAD VBAʵƤֱߡԲ

ӭתأת[ݲwww.tiancao.net] ԭӣhttp://www.tiancao.net/blogview.asp?logID=214&cateID=3